home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / WIN_VB / VBINT.ZIP;1 / INTDEMO.BAS < prev    next >
Encoding:
BASIC Source File  |  1994-06-04  |  32.0 KB  |  1,222 lines
  1. '---------------------------------------------------------------------------
  2. ' DOS Interrupt Demo Program, Copyright (c) 1994 Karl E. Peterson
  3. ' Redistributed by permission.
  4. '
  5. ' Requires: VBInt.DLL, VBRun300.DLL
  6. '
  7. ' This program may be distributed freely on the condition that it is
  8. ' distributed in full, and unmodified, and that no fee is charged for such
  9. ' distribution with the exception of reasonable media and shipping charges.
  10. ' Any or all portions of the source code may be incorporated into your own
  11. ' programs, and those programs may be distributed without payment of
  12. ' royalties on the condition that such programs differ substantially from
  13. ' this demonstration program.
  14. '
  15. ' This program is distributed AS IS.  The author acknowledges absolutely
  16. ' no liability for its use or misuse.  The sole purpose of this program is to
  17. ' demonstrate some of the powerful capabilities of VBInt.DLL, written and
  18. ' copyrighted by Rick Esterling.  Calling DOS interrupts from Windows is
  19. ' fairly "non-standard" behavior.  Users of this program acknowledge that
  20. ' they are doing so at their OWN RISK.
  21. '
  22. ' This demonstration program was created and distributed by:
  23. '   Karl E. Peterson
  24. '   Regional Transportation Council
  25. '   1351 Officers' Row
  26. '   Vancouver, Washington 98661
  27. '   CompuServe: 72302,3707
  28. '
  29. ' Your comments or questions are invited!
  30. '---------------------------------------------------------------------------
  31.  
  32. DefInt A-Z
  33. Option Explicit
  34.  
  35. Type VBRegs
  36.   AX      As Integer
  37.   BX      As Integer
  38.   CX      As Integer
  39.   DX      As Integer
  40.   SI      As Integer
  41.   DI      As Integer
  42.   cFlag   As Integer
  43.   DS      As Integer
  44.   ES      As Integer
  45. End Type
  46.  
  47. Declare Function VBInt% Lib "vbint.dll" Alias "#1" (ByVal ServNum%, InRegs As VBRegs, OutRegs As VBRegs)
  48. Declare Function GetSegment% Lib "vbint.dll" Alias "#2" (ByVal IntVar As String)
  49. Declare Function GetOffset% Lib "vbint.dll" Alias "#3" (ByVal IntVar As String)
  50. Declare Function UDTSegment% Lib "vbint.dll" Alias "#2" (IntVar As Any)
  51. Declare Function UDTOffset% Lib "vbint.dll" Alias "#3" (IntVar As Any)
  52.  
  53. Type FileDataType
  54.   FileName    As String * 12   'useful for display purposes
  55.   sDate       As Double
  56.   Attr        As Integer
  57.   Size        As Long
  58.   name83      As String * 11   'useful for sorting on name
  59.   name38      As String * 11   'useful for sorting on extension
  60.   year        As Integer
  61.   month       As Integer
  62.   day         As Integer
  63.   hour        As Integer
  64.   minute      As Integer
  65.   second      As Integer
  66. End Type
  67.  
  68. Type DiskFreeSpaceType
  69.   sectorsPerCluster   As Integer
  70.   bytesPerSector      As Integer
  71.   clustersPerDrive    As Long
  72.   availableClusters   As Long
  73.   availableBytes      As Long
  74.   totalBytes          As Long
  75.   allocationSize      As Long
  76. End Type
  77.  
  78. Type DTAType                     'used by DOS file services
  79.   Reserved  As String * 21       'reserved for use by DOS
  80.   Attribute As String * 1        'the file's attribute
  81.   FileTime  As Integer           'the file's time
  82.   FileDate  As Integer           'the file's date
  83.   FileSize  As Long              'the file's size
  84.   FileName  As String * 13       'the file's name
  85. End Type
  86.  
  87. Type SerialNumberType
  88.   InfoLev   As Integer
  89.   SerNum    As String * 4
  90.   Volume    As String * 11
  91.   SysType   As String * 8
  92. End Type
  93.  
  94. Type ReadWriteBlockType
  95.   rwSpecFunc    As String * 1
  96.   rwHead        As Integer
  97.   rwCylinder    As Integer
  98.   rwFirstSector As Integer
  99.   rwSectors     As Integer
  100.   rwBuffer      As Long
  101. End Type
  102.  
  103. Global DosVersion As Integer
  104.  
  105. 'Constants
  106. Global Const attrNormal = 0
  107. Global Const attrReadOnly = 1
  108. Global Const attrHidden = 2
  109. Global Const attrSystem = 4
  110. Global Const attrVolume = 8
  111. Global Const attrDirectory = 16
  112. Global Const attrArchived = 32
  113. Global Const attrAllFile = attrReadOnly + attrHidden + attrSystem + attrArchived
  114. Global Const attrAllDir = attrDirectory + attrHidden + attrReadOnly
  115. Global Const attrAll = attrAllFile + attrDirectory
  116. Global Const attrAllNorm = attrReadOnly + attrArchived + attrDirectory
  117.  
  118. ' MsgBox parameters
  119. Global Const MB_OK = 0                 ' OK button only
  120. Global Const MB_OKCANCEL = 1           ' OK and Cancel buttons
  121. Global Const MB_ABORTRETRYIGNORE = 2   ' Abort, Retry, and Ignore buttons
  122. Global Const MB_YESNOCANCEL = 3        ' Yes, No, and Cancel buttons
  123. Global Const MB_YESNO = 4              ' Yes and No buttons
  124. Global Const MB_RETRYCANCEL = 5        ' Retry and Cancel buttons
  125. Global Const MB_ICONSTOP = 16          ' Critical message
  126. Global Const MB_ICONQUESTION = 32      ' Warning query
  127. Global Const MB_ICONEXCLAMATION = 48   ' Warning message
  128. Global Const MB_ICONINFORMATION = 64   ' Information message
  129. Global Const MB_APPLMODAL = 0          ' Application Modal Message Box
  130. Global Const MB_DEFBUTTON1 = 0         ' First button is default
  131. Global Const MB_DEFBUTTON2 = 256       ' Second button is default
  132. Global Const MB_DEFBUTTON3 = 512       ' Third button is default
  133. Global Const MB_SYSTEMMODAL = 4096      'System Modal
  134.  
  135. ' MsgBox return values
  136. Global Const IDOK = 1                  ' OK button pressed
  137. Global Const IDCANCEL = 2              ' Cancel button pressed
  138. Global Const IDABORT = 3               ' Abort button pressed
  139. Global Const IDRETRY = 4               ' Retry button pressed
  140. Global Const IDIGNORE = 5              ' Ignore button pressed
  141. Global Const IDYES = 6                 ' Yes button pressed
  142. Global Const IDNO = 7                  ' No button pressed
  143.  
  144. ' API Calls
  145. Declare Function GetWindowsDirectory Lib "Kernel" (ByVal lpBuffer As String, ByVal nSize As Integer) As Integer
  146. Declare Function GetSystemDirectory Lib "Kernel" (ByVal lpBuffer As String, ByVal nSize As Integer) As Integer
  147. Declare Function GetVersion Lib "Kernel" () As Long
  148. Declare Function GetWinFlags Lib "Kernel" () As Long
  149. Declare Function SendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long
  150.  
  151. ' Private Window Messages Start Here:
  152. Global Const WM_USER = &H400
  153.  
  154. ' Listbox messages
  155. Global Const LB_ADDSTRING = (WM_USER + 1)
  156. Global Const LB_INSERTSTRING = (WM_USER + 2)
  157. Global Const LB_DELETESTRING = (WM_USER + 3)
  158. Global Const LB_RESETCONTENT = (WM_USER + 5)
  159. Global Const LB_SETSEL = (WM_USER + 6)
  160. Global Const LB_SETCURSEL = (WM_USER + 7)
  161. Global Const LB_GETSEL = (WM_USER + 8)
  162. Global Const LB_GETCURSEL = (WM_USER + 9)
  163. Global Const LB_GETTEXT = (WM_USER + 10)
  164. Global Const LB_GETTEXTLEN = (WM_USER + 11)
  165. Global Const LB_GETCOUNT = (WM_USER + 12)
  166. Global Const LB_SELECTSTRING = (WM_USER + 13)
  167. Global Const LB_DIR = (WM_USER + 14)
  168. Global Const LB_GETTOPINDEX = (WM_USER + 15)
  169. Global Const LB_FINDSTRING = (WM_USER + 16)
  170. Global Const LB_GETSELCOUNT = (WM_USER + 17)
  171. Global Const LB_GETSELITEMS = (WM_USER + 18)
  172. Global Const LB_SETTABSTOPS = (WM_USER + 19)
  173. Global Const LB_GETHORIZONTALEXTENT = (WM_USER + 20)
  174. Global Const LB_SETHORIZONTALEXTENT = (WM_USER + 21)
  175. Global Const LB_SETCOLUMNWIDTH = (WM_USER + 22)
  176. Global Const LB_SETTOPINDEX = (WM_USER + 24)
  177. Global Const LB_GETITEMRECT = (WM_USER + 25)
  178. Global Const LB_GETITEMDATA = (WM_USER + 26)
  179. Global Const LB_SETITEMDATA = (WM_USER + 27)
  180. Global Const LB_SELITEMRANGE = (WM_USER + 28)
  181. Global Const LB_MSGMAX = (WM_USER + 33)
  182.  
  183. ' Constants used with GetWinFlags()
  184. Global Const WF_PMODE = &H1
  185. Global Const WF_CPU286 = &H2
  186. Global Const WF_CPU386 = &H4
  187. Global Const WF_CPU486 = &H8
  188. Global Const WF_STANDARD = &H10
  189. Global Const WF_WIN286 = &H10
  190. Global Const WF_ENHANCED = &H20
  191. Global Const WF_WIN386 = &H20
  192. Global Const WF_CPU086 = &H40
  193. Global Const WF_CPU186 = &H80
  194. Global Const WF_80x87 = &H400
  195. Global Const WF_CPUR4000 = &H100
  196. Global Const WF_CPUALPHA21064 = &H200
  197. Global Const WF_WINNT = &H4000
  198.  
  199. Function DosAnsiLoaded ()
  200.   
  201.   Dim Regs As VBRegs, Rtn%, AH%, AL%
  202.   Regs.AX = &H1A00
  203.   Rtn% = VBInt(&H2F, Regs, Regs)
  204.  
  205.   WordSplit Regs.AX, AH, AL
  206.   If AL = &HFF Then
  207.     DosAnsiLoaded = True
  208.   Else
  209.     DosAnsiLoaded = False
  210.   End If
  211.  
  212. End Function
  213.  
  214. Function DosAppendLoaded ()
  215.   
  216.   Dim Regs As VBRegs, Rtn%, AH%, AL%
  217.   Regs.AX = &H2F00
  218.   Rtn% = VBInt(&H2F, Regs, Regs)
  219.  
  220.   WordSplit Regs.AX, AH, AL
  221.   If AL = &HFF Then
  222.     DosAppendLoaded = True
  223.   Else
  224.     DosAppendLoaded = False
  225.   End If
  226.  
  227. End Function
  228.  
  229. Function DosAssignLoaded ()
  230.  
  231.   Dim Regs As VBRegs, Rtn%, AH%, AL%
  232.   Regs.AX = &H600
  233.   Rtn% = VBInt(&H2F, Regs, Regs)
  234.  
  235.   WordSplit Regs.AX, AH, AL
  236.   If AL = &HFF Then
  237.     DosAssignLoaded = True
  238.   Else
  239.     DosAssignLoaded = False
  240.   End If
  241.  
  242. End Function
  243.  
  244. Function DosDblSpaceLoaded ()
  245.  
  246.   Dim Regs As VBRegs, Rtn%, CH%, CL%
  247.   Regs.AX = &H4A11
  248.   Regs.BX = 0
  249.   Rtn% = VBInt(&H2F, Regs, Regs)
  250.  
  251.   
  252.   If Regs.AX = &H0 And Regs.BX = &H444D Then
  253.     DosDblSpaceLoaded = True
  254.     'CL = First drive letter used by DoubleSpace (0-based)
  255.     'CH = Number of drive letters used by DoubleSpace
  256.     'DX = DBLSPACE.BIN version number; this is an internal version number
  257.     '     which is used by DBLSPACE.BIN, IO.SYS, and DBLSPACE.EXE to
  258.     '     ensure that their interfaces are consistent.
  259.     WordSplit Regs.CX, CH, CL
  260.   Else
  261.     DosDblSpaceLoaded = False
  262.   End If
  263.  
  264. End Function
  265.  
  266. Function DosDosKeyLoaded ()
  267.  
  268.   Dim Regs As VBRegs, Rtn%, AH%, AL%
  269.   Regs.AX = &H4800
  270.   Rtn% = VBInt(&H2F, Regs, Regs)
  271.  
  272.   WordSplit Regs.AX, AH, AL
  273.   If AL = &H0 Then
  274.     DosDosKeyLoaded = False
  275.   Else
  276.     DosDosKeyLoaded = True
  277.   End If
  278.  
  279. End Function
  280.  
  281. Function DosErrorMsg$ (ErrorCode%)
  282.  
  283.   Dim t$
  284.   Select Case ErrorCode
  285.     Case 0:  t$ = ""
  286.     Case 1:  t$ = "Function Number Invalid"
  287.     Case 2:  t$ = "File Not Found"
  288.     Case 3:  t$ = "Path Not Found"
  289.     Case 4:  t$ = "Too Many Open Files"
  290.     Case 5:  t$ = "Access Denied"
  291.     Case 6:  t$ = "Handle Invalid"
  292.     Case 7:  t$ = "Memory Control Block Invalid"
  293.     Case 8:  t$ = "Insufficient Memory"
  294.     Case 9:  t$ = "Memory Block Address Invalid"
  295.     Case 10: t$ = "Environment Invalid"
  296.     Case 11: t$ = "Format Invalid"
  297.     Case 12: t$ = "Access Code Invalid"
  298.     Case 13: t$ = "Data Invalid"
  299.     Case 14: t$ = "Unknown Unit"
  300.     Case 15: t$ = "Disk Drive Invalid"
  301.     Case 16: t$ = "Attempted to Remove Current Directory"
  302.     Case 17: t$ = "Not Same Device"
  303.     Case 18: t$ = "No More Files"
  304.     Case 19: t$ = "Disk Write Protected"
  305.     Case 20: t$ = "Unknown Unit"
  306.     Case 21: t$ = "Drive Not Ready"
  307.     Case 22: t$ = "Unknown Command"
  308.     Case 23: t$ = "Data Error (CRC)"
  309.     Case 24: t$ = "Bad Request Structure Length"
  310.     Case 25: t$ = "Seek Error"
  311.     Case 26: t$ = "Unknown Media Type"
  312.     Case 27: t$ = "Sector Not Found"
  313.     Case 28: t$ = "Printer Out of Paper"
  314.     Case 29: t$ = "Write Fault"
  315.     Case 30: t$ = "Read Fault"
  316.     Case 31: t$ = "General Failure"
  317.     Case 32: t$ = "Sharing Violation"
  318.     Case 33: t$ = "Lock Violation"
  319.     Case 34: t$ = "Disk Change Invalid"
  320.     Case 35: t$ = "FCB Unavailable"
  321.     Case 36: t$ = "Sharing Buffer Exceeded"
  322.     Case 37 To 49: t$ = "Reserved"
  323.     Case 50: t$ = "Unsupported Network Request"
  324.     Case 51: t$ = "Remote Machine Not Listening"
  325.     Case 52: t$ = "Duplicate Name in Network"
  326.     Case 53: t$ = "Network Name not Found"
  327.     Case 54: t$ = "Network Busy"
  328.     Case 55: t$ = "Device No Longer Exists on Network"
  329.     Case 56: t$ = "NetBIOS Command Limit Exceeded"
  330.     Case 57: t$ = "Error in Network Adapter Hardware"
  331.     Case 58: t$ = "Incorrect Response from Network"
  332.     Case 59: t$ = "Unexpected Network Error"
  333.     Case 60: t$ = "Remote Adapter Incompatible"
  334.     Case 61: t$ = "Print Queue Full"
  335.     Case 62: t$ = "Queue Not Full"
  336.     Case 63: t$ = "Not Enough Room for Print File"
  337.     Case 64: t$ = "Network Name Deleted"
  338.     Case 65: t$ = "Access Denied"
  339.     Case 66: t$ = "Incorrect Network Device Type"
  340.     Case 67: t$ = "Network Name Not Found"
  341.     Case 68: t$ = "Network Name Limit Exceeded"
  342.     Case 69: t$ = "NetBIOS Session Limit Exceeded"
  343.     Case 70: t$ = "Temporary Pause"
  344.     Case 71: t$ = "Network Request Not Accepted"
  345.     Case 72: t$ = "Print or Disk Redirection Paused"
  346.     Case 73 To 79: t$ = "Reserved"
  347.     Case 80: t$ = "File Already Exists"
  348.     Case 81: t$ = "Reserved"
  349.     Case 82: t$ = "Cannot Make Directory"
  350.     Case 83: t$ = "Fail on Int 24H (Critical Error)"
  351.     Case 84: t$ = "Out of Structures"
  352.     Case 85: t$ = "Already Assigned"
  353.     Case 86: t$ = "Invalid Password"
  354.     Case 87: t$ = "Invalid Parameter"
  355.     Case 88: t$ = "Net Write Fault"
  356.     Case Else: t$ = "Unknown Error"
  357.   End Select
  358.   DosErrorMsg$ = t$
  359.  
  360. End Function
  361.  
  362. Function DosGetVersion ()
  363.  
  364.   Dim Regs As VBRegs, Rtn%
  365.   Regs.AX = &H3000
  366.   Rtn% = VBInt(&H21, Regs, Regs)
  367.  
  368.   DosGetVersion = ByteLo(Regs.AX) * 100 + ByteHi(Regs.AX)
  369.  
  370. End Function
  371.  
  372. Function DosGraftablLoaded ()
  373.  
  374.   Dim Regs As VBRegs, Rtn%, AH%, AL%
  375.   Regs.AX = &HB000
  376.   Rtn% = VBInt(&H2F, Regs, Regs)
  377.  
  378.   WordSplit Regs.AX, AH, AL
  379.   If AL = &HFF Then
  380.     DosGraftablLoaded = True
  381.   Else
  382.     DosGraftablLoaded = False
  383.   End If
  384.  
  385. End Function
  386.  
  387. Function DosHimemLoaded ()
  388.  
  389.   Dim Regs As VBRegs, Rtn%, AH%, AL%
  390.   Regs.AX = &H4300
  391.   Rtn% = VBInt(&H2F, Regs, Regs)
  392.  
  393.   WordSplit Regs.AX, AH, AL
  394.   If AL = &H80 Then
  395.     DosHimemLoaded = True
  396.   Else
  397.     DosHimemLoaded = False
  398.   End If
  399.  
  400. End Function
  401.  
  402. Function DosNetworkLoaded ()
  403.  
  404.   Dim Regs As VBRegs, Rtn%, AH%, AL%
  405.   Regs.AX = &H1100
  406.   Rtn% = VBInt(&H2F, Regs, Regs)
  407.  
  408.   WordSplit Regs.AX, AH, AL
  409.   If AL = &HFF Then
  410.     DosNetworkLoaded = True
  411.   Else
  412.     DosNetworkLoaded = False
  413.   End If
  414.  
  415. End Function
  416.  
  417. Function DosNlsfuncLoaded ()
  418.  
  419.   Dim Regs As VBRegs, Rtn%, AH%, AL%
  420.   Regs.AX = &H1400
  421.   Rtn% = VBInt(&H2F, Regs, Regs)
  422.  
  423.   WordSplit Regs.AX, AH, AL
  424.   If AL = &HFF Then
  425.     DosNlsfuncLoaded = True
  426.   Else
  427.     DosNlsfuncLoaded = False
  428.   End If
  429.  
  430. End Function
  431.  
  432. Function DosPrintLoaded ()
  433.  
  434.   Dim Regs As VBRegs, Rtn%, AH%, AL%
  435.   Regs.AX = &H100
  436.   Rtn% = VBInt(&H2F, Regs, Regs)
  437.  
  438.   WordSplit Regs.AX, AH, AL
  439.   If AL = &HFF Then
  440.     DosPrintLoaded = True
  441.   Else
  442.     DosPrintLoaded = False
  443.   End If
  444.  
  445. End Function
  446.  
  447. Function DosShareLoaded ()
  448.  
  449.   Dim Regs As VBRegs, Rtn%, AH%, AL%
  450.   Regs.AX = &H1000
  451.   Rtn% = VBInt(&H2F, Regs, Regs)
  452.  
  453.   WordSplit Regs.AX, AH, AL
  454.   If AL = &HFF Then
  455.     DosShareLoaded = True
  456.   Else
  457.     DosShareLoaded = False
  458.   End If
  459.  
  460. End Function
  461.  
  462. Function DrvCDRom (Drive$)
  463.   
  464.   Dim Rtn%, Reg As VBRegs, Buffer$
  465.   
  466.   'Test for MSCDEX first
  467.     Reg.AX = &H1500
  468.     Rtn% = VBInt(&H2F, Reg, Reg)
  469.     If Reg.BX = 0 Then
  470.       DrvCDRom = False
  471.       Exit Function
  472.     End If
  473.  
  474.   'Test drive
  475.     Reg.AX = &H150B
  476.     If Len(Drive$) Then
  477.       Reg.CX = Asc(UCase$(Drive$)) - 65
  478.     Else
  479.       Reg.CX = Asc(UCase$(CurDir$)) - 65
  480.     End If
  481.     Rtn% = VBInt(&H2F, Reg, Reg)
  482.     DrvCDRom = Reg.AX
  483.  
  484. End Function
  485.  
  486. Sub DrvFreeSpace (Drive$, disk As DiskFreeSpaceType)
  487.   
  488.   Dim Regs As VBRegs
  489.   Dim Rtn%
  490.  
  491.   Regs.AX = &H3600
  492.   If Len(Drive$) Then
  493.     Regs.DX = Asc(UCase$(Drive$)) - 64
  494.   Else
  495.     Regs.DX = 0 'default drive
  496.   End If
  497.   Rtn% = VBInt(&H21, Regs, Regs)
  498.   
  499.   disk.sectorsPerCluster = Regs.AX
  500.   disk.bytesPerSector = Regs.CX
  501.  
  502.   If Regs.DX >= 0 Then
  503.       disk.clustersPerDrive = Regs.DX
  504.   Else
  505.       disk.clustersPerDrive = Regs.DX + 65536
  506.   End If
  507.  
  508.   If Regs.BX >= 0 Then
  509.       disk.availableClusters = Regs.BX
  510.   Else
  511.       disk.availableClusters = Regs.BX + 65536
  512.   End If
  513.  
  514.   disk.allocationSize = CLng(Regs.AX) * CLng(Regs.CX)
  515.   disk.availableBytes = disk.availableClusters * disk.allocationSize
  516.   disk.totalBytes = disk.clustersPerDrive * disk.allocationSize
  517.  
  518. End Sub
  519.  
  520. Function DrvGetDir% (Drive$, ReturnDir$)
  521.   
  522.   Dim Rtn%, Reg As VBRegs, Buffer$
  523.   Reg.AX = &H4700
  524.   If Len(Drive$) Then
  525.     Reg.DX = Asc(UCase$(Drive$)) - 64
  526.   Else
  527.     Reg.DX = 0 'default drive
  528.   End If
  529.   Buffer$ = Space$(128) + Chr$(0)
  530.   Reg.DS = GetSegment(Buffer$)
  531.   Reg.SI = GetOffset(Buffer$)
  532.   Rtn% = VBInt(&H21, Reg, Reg)
  533.  
  534.   If Reg.cFlag Then
  535.     ReturnDir$ = DosErrorMsg$(Reg.AX)
  536.     DrvGetDir = False
  537.   Else
  538.     ReturnDir$ = "\" + Left$(Buffer$, InStr(Buffer$, Chr$(0)) - 1)
  539.     DrvGetDir = True
  540.   End If
  541.  
  542. End Function
  543.  
  544. Function DrvGetSerNum (Drive$, SerialNum$)
  545.  
  546. 'Initialization
  547.   Dim BootSector$, OEM$, SN$, Vol$, FileSys$, i%
  548.  
  549. 'Read in boot sector
  550.   If DrvTrackRead(Drive$, 0, 0, 0, 1, BootSector$) Then
  551.     FileSys$ = Mid$(BootSector$, 55, 8)
  552.     If InStr(FileSys$, "FAT") = 1 Then
  553.       OEM$ = Mid$(BootSector$, 4, 8)
  554.       SN$ = Mid$(BootSector$, 40, 4)
  555.       Vol$ = Mid$(BootSector$, 44, 11)
  556.       For i = 4 To 1 Step -1
  557.     SerialNum$ = SerialNum$ + HexFmt2$(Asc(Mid$(SN$, i, 1)))
  558.       Next i
  559.       SerialNum$ = Left$(SerialNum$, 4) + "-" + Right$(SerialNum$, 4)
  560.       DrvGetSerNum = True
  561.     Else 'not a DOS drive
  562.       DrvGetSerNum = False
  563.     End If
  564.   Else 'failed to read boot sector
  565.     DrvGetSerNum = False
  566.   End If
  567.  
  568. End Function
  569.  
  570. Function DrvGetVolume$ (Drive$)
  571.  
  572.   Dim Vol$
  573.   Vol$ = Drive$
  574.   If Len(Vol$) = 0 Then
  575.     Vol$ = CurDir$
  576.   End If
  577.   Vol$ = UCase$(Left$(Vol$, 1)) + ":\*.*"
  578.  
  579.   Dim DTA As DTAType, ErrorCode%, Rtn%
  580.   Rtn = FileFindFirst(Vol$, DTA, attrVolume, ErrorCode)
  581.   Vol$ = Left$(DTA.FileName, InStr(DTA.FileName, Chr$(0)) - 1)
  582.   If InStr(Vol$, ".") Then
  583.     Vol$ = Left$(Vol$, 8) + Mid$(Vol$, 10)
  584.   End If
  585.   DrvGetVolume$ = Vol$
  586.  
  587. End Function
  588.  
  589. Function DrvRemote (Drive$)
  590.  
  591.   Dim Regs As VBRegs
  592.   Dim Rtn%
  593.  
  594.   Regs.AX = &H4409
  595.   If Len(Drive$) Then
  596.     Regs.BX = Asc(UCase$(Drive$)) - 64
  597.   Else
  598.     Regs.BX = 0 'default drive
  599.   End If
  600.   Rtn% = VBInt(&H21, Regs, Regs)
  601.  
  602.   If Regs.cFlag Then
  603.     'error occured (code in AX)
  604.     DrvRemote = False
  605.   Else
  606.     If Regs.DX And (2 ^ 12) Then
  607.       DrvRemote = True
  608.     Else
  609.       DrvRemote = False
  610.     End If
  611.   End If
  612.  
  613. End Function
  614.  
  615. Function DrvRemovable (Drive$)
  616.  
  617.   Dim Regs As VBRegs
  618.   Dim Rtn%
  619.  
  620.   Regs.AX = &H4408
  621.   If Len(Drive$) Then
  622.     Regs.BX = Asc(UCase$(Drive$)) - 64
  623.   Else
  624.     Regs.BX = 0 'default drive
  625.   End If
  626.   Rtn% = VBInt(&H21, Regs, Regs)
  627.  
  628.   If Regs.cFlag Then
  629.     'error occured (code in AX), assume not removable
  630.     DrvRemovable = False
  631.   Else
  632.     If Regs.AX = 0 Then
  633.       DrvRemovable = True
  634.     ElseIf Regs.AX = 1 Then
  635.       DrvRemovable = False
  636.     End If
  637.   End If
  638.  
  639. End Function
  640.  
  641. Function DrvSetSerNum (Drive$, NewSerialNum&)
  642.  
  643. 'Initialization
  644.   Dim BootSector$, OEM$, SN$, Vol$, FileSys$, i%
  645.   Dim Lo%, Hi%
  646.  
  647. 'Read in boot sector
  648.   If DrvTrackRead(Drive$, 0, 0, 0, 1, BootSector$) Then
  649.     FileSys$ = Mid$(BootSector$, 55, 8)
  650.     If InStr(FileSys$, "FAT") = 1 Then
  651.       SN$ = Mid$(BootSector$, 40, 4)
  652.       Hi = WordHi(NewSerialNum)
  653.       Lo = WordLo(NewSerialNum)
  654.       SN$ = Chr$(ByteLo(Lo)) + Chr$(ByteHi(Lo)) + Chr$(ByteLo(Hi)) + Chr$(ByteHi(Hi))
  655.       Mid$(BootSector$, 40, 4) = SN$
  656.       If DrvTrackWrite(Drive$, 0, 0, 0, 1, BootSector$) Then
  657.     DrvSetSerNum = True
  658.       Else
  659.     DrvSetSerNum = False
  660.       End If
  661.     Else 'not a DOS drive
  662.       DrvSetSerNum = False
  663.     End If
  664.   Else 'failed to read boot sector
  665.     DrvSetSerNum = False
  666.   End If
  667.  
  668. End Function
  669.  
  670. Function DrvSetVolume (Drive$, NewVolume$)
  671.  
  672. 'NOT fully functional yet!  Only changes boot sector,
  673. 'but doesn't affect root directory.
  674.  
  675. 'Initialization
  676.   Dim BootSector$, OEM$, SN$, Vol$, FileSys$, i%
  677.   Dim Lo%, Hi%
  678.  
  679. 'Read in boot sector
  680.   If DrvTrackRead(Drive$, 0, 0, 0, 1, BootSector$) Then
  681.     FileSys$ = Mid$(BootSector$, 55, 8)
  682.     If InStr(FileSys$, "FAT") = 1 Then
  683.       'OEM$ = Mid$(BootSector$, 4, 8)
  684.       'SN$ = Mid$(BootSector$, 40, 4)
  685.       'Vol$ = Mid$(BootSector$, 44, 11)
  686.       Vol$ = Left$(Left$(NewVolume$, 11) + Space$(11), 11)
  687.       Mid$(BootSector$, 44, 11) = Vol$
  688.       If DrvTrackWrite(Drive$, 0, 0, 0, 1, BootSector$) Then
  689.     DrvSetVolume = True
  690.       Else
  691.     DrvSetVolume = False
  692.       End If
  693.     Else 'not a DOS drive
  694.       DrvSetVolume = False
  695.     End If
  696.   Else 'failed to read boot sector
  697.     DrvSetVolume = False
  698.   End If
  699.  
  700. End Function
  701.  
  702. Function DrvTrackRead% (Drive$, dHead%, dCyl%, d1Sec%, dNSec%, Buffer$)
  703.  
  704.   Dim Regs As VBRegs
  705.   Dim rwBlock As ReadWriteBlockType
  706.   Dim disk As DiskFreeSpaceType
  707.   Dim BufSeg%, BufOff%
  708.   Dim Rtn%
  709.  
  710.   DrvFreeSpace Drive$, disk
  711.   Buffer$ = Space$(dNSec * disk.bytesPerSector)
  712.   BufSeg = GetSegment(Buffer$)
  713.   BufOff = GetOffset(Buffer$)
  714.  
  715.   rwBlock.rwSpecFunc = Chr$(0)
  716.   rwBlock.rwHead = dHead
  717.   rwBlock.rwCylinder = dCyl
  718.   rwBlock.rwFirstSector = d1Sec
  719.   rwBlock.rwSectors = dNSec
  720.   rwBlock.rwBuffer = BufSeg * 65536 + BufOff
  721.  
  722.   Regs.AX = &H440D
  723.   If Len(Drive$) Then
  724.     Regs.BX = Asc(UCase$(Drive$)) - 64
  725.   Else
  726.     Regs.BX = 0 'default drive
  727.   End If
  728.   Regs.CX = &H861
  729.   Regs.DS = UDTSegment(rwBlock)
  730.   Regs.DX = UDTOffset(rwBlock)
  731.   Rtn% = VBInt(&H21, Regs, Regs)
  732.  
  733.   If Regs.cFlag Then
  734.     Buffer$ = DosErrorMsg$(Regs.AX)
  735.     DrvTrackRead = False
  736.   Else
  737.     DrvTrackRead = True
  738.   End If
  739.  
  740. End Function
  741.  
  742. Function DrvTrackWrite% (Drive$, dHead%, dCyl%, d1Sec%, dNSec%, Buffer$)
  743.  
  744.   Dim Regs As VBRegs
  745.   Dim rwBlock As ReadWriteBlockType
  746.   Dim disk As DiskFreeSpaceType
  747.   Dim BufSeg%, BufOff%
  748.   Dim Rtn%
  749.  
  750.   DrvFreeSpace Drive$, disk
  751.   If Len(Buffer) <> dNSec * disk.bytesPerSector Then
  752.     DrvTrackWrite = False
  753.     Exit Function
  754.   End If
  755.  
  756.   BufSeg = GetSegment(Buffer$)
  757.   BufOff = GetOffset(Buffer$)
  758.  
  759.   rwBlock.rwSpecFunc = Chr$(0)
  760.   rwBlock.rwHead = dHead
  761.   rwBlock.rwCylinder = dCyl
  762.   rwBlock.rwFirstSector = d1Sec
  763.   rwBlock.rwSectors = dNSec
  764.   rwBlock.rwBuffer = BufSeg * 65536 + BufOff
  765.  
  766.   Regs.AX = &H440D
  767.   If Len(Drive$) Then
  768.     Regs.BX = Asc(UCase$(Drive$)) - 64
  769.   Else
  770.     Regs.BX = 0 'default drive
  771.   End If
  772.   Regs.CX = &H841
  773.   Regs.DS = UDTSegment(rwBlock)
  774.   Regs.DX = UDTOffset(rwBlock)
  775.   Rtn% = VBInt(&H21, Regs, Regs)
  776.  
  777.   If Regs.cFlag Then
  778.     Buffer$ = DosErrorMsg$(Regs.AX)
  779.     DrvTrackWrite = False
  780.   Else
  781.     DrvTrackWrite = True
  782.   End If
  783.  
  784. End Function
  785.  
  786. Function FileExists (FileSpec$) As Integer
  787.  
  788. 'Check for existence using DOS "Search for first match" service &h4E
  789.   If Len(FileSpec$) = 0 Or InStr(FileSpec$, "*") > 0 Or InStr(FileSpec$, "?") > 0 Then
  790.     FileExists = False
  791.     Exit Function
  792.   End If
  793.  
  794. 'Initialization
  795.   Dim Regs As VBRegs, Rtn%
  796.   Dim DtaSeg%, DtaOff%, Spec$
  797.   
  798.   Regs.AX = &H4E00
  799.   Regs.CX = attrAll      'Search for all file attributes
  800.   Spec$ = FileSpec$ + Chr$(0)
  801.   Regs.DS = GetSegment(Spec$)
  802.   Regs.DX = GetOffset(Spec$)
  803.   Rtn = VBInt(&H21, Regs, Regs)
  804.  
  805.   Select Case Regs.AX
  806.     Case 0
  807.       FileExists = True
  808.     Case Else
  809.       FileExists = False
  810.   End Select
  811.  
  812. End Function
  813.  
  814. Static Function FileFindFirst (Path$, DTA As DTAType, Attribute%, ErrorCode%)
  815.  
  816. 'Initialization
  817.   Dim Regs As VBRegs, Rtn%
  818.   Dim DtaSeg%, DtaOff%, ThePath$
  819.  
  820. 'The path must be a null terminated string
  821.   ThePath$ = Trim$(Path$) + Chr$(0)
  822.  
  823. 'Get current DTA address
  824.   Regs.AX = &H2F00
  825.   Rtn% = VBInt(&H21, Regs, Regs)
  826.   DtaSeg = Regs.ES
  827.   DtaOff = Regs.BX
  828.  
  829. 'Set dta address
  830.   Regs.AX = &H1A00
  831.   Regs.DS = UDTSegment(DTA)
  832.   Regs.DX = UDTOffset(DTA)
  833.   Rtn% = VBInt(&H21, Regs, Regs)
  834.  
  835. 'Find first file match
  836.   Regs.AX = &H4E00
  837.   Regs.CX = Attribute
  838.   Regs.DS = GetSegment(ThePath$)
  839.   Regs.DX = GetOffset(ThePath$)
  840.   Rtn% = VBInt(&H21, Regs, Regs)
  841.  
  842. 'The carry flag tells if a file was found or not
  843.   If Regs.cFlag And 1 Then 'Carry Flag Set
  844.     ErrorCode = Regs.AX
  845.     FileFindFirst = False
  846.   Else  'Carry Flag Clear
  847.     ErrorCode = 0
  848.     FileFindFirst = True
  849.   End If
  850.   
  851. 'Reset the original DTA
  852.   Regs.AX = &H1A00
  853.   Regs.DS = DtaSeg
  854.   Regs.DX = DtaOff
  855.   Rtn% = VBInt(&H21, Regs, Regs)
  856.  
  857. End Function
  858.  
  859. Static Function FileFindNext (DTA As DTAType, Attribute%, ErrorCode%)
  860. 'NOTE:  DTA absolutely *MUST* be initialized by FileFindFirst before calling here!!!
  861.  
  862. 'Initialization
  863.   Dim Regs As VBRegs, Rtn%
  864.   Dim DtaSeg%, DtaOff%
  865.   
  866. 'Get current DTA address
  867.   Regs.AX = &H2F00
  868.   Rtn% = VBInt(&H21, Regs, Regs)
  869.   DtaSeg = Regs.ES
  870.   DtaOff = Regs.BX
  871.  
  872. 'Set DTA address
  873.   Regs.AX = &H1A00
  874.   Regs.DS = UDTSegment(DTA)
  875.   Regs.DX = UDTOffset(DTA)
  876.   Rtn% = VBInt(&H21, Regs, Regs)
  877.  
  878. 'Find next file match
  879.   Regs.AX = &H4F00
  880.   'Regs.CX = Attribute
  881.   Rtn% = VBInt(&H21, Regs, Regs)
  882.  
  883. 'The carry flag tells whether a file was found or not
  884.   If Regs.cFlag And 1 Then 'Carry Flag Set
  885.     ErrorCode = Regs.AX
  886.     FileFindNext = False
  887.   Else                     'Carry Flag Clear
  888.     ErrorCode = 0
  889.     FileFindNext = True
  890.   End If
  891.   
  892. 'Reset the original DTA
  893.   Regs.AX = &H1A00
  894.   Regs.DS = DtaSeg
  895.   Regs.DX = DtaOff
  896.   Rtn% = VBInt(&H21, Regs, Regs)
  897.  
  898. End Function
  899.  
  900. Static Sub FileGetData (DTA As DTAType, File As FileDataType)
  901.  
  902.   Dim Tim&, Dat&, dot%
  903.   
  904.   File.Attr = Asc(DTA.Attribute)
  905.  
  906.   Tim& = DTA.FileTime
  907.   If Tim& < 0 Then Tim& = Tim& + 65536
  908.   File.second = Tim& And &H1F
  909.   File.minute = (Tim& \ &H20) And &H3F
  910.   File.hour = (Tim& \ &H800) And &H1F
  911.  
  912.   Dat& = DTA.FileDate
  913.   File.day = Dat& And &H1F
  914.   File.month = (Dat& \ &H20) And &HF
  915.   File.year = ((Dat& \ &H200) And &H1F) + 1980
  916.  
  917.   File.Size = DTA.FileSize
  918.   File.sDate = DateSerial(File.year, File.month, File.day) + TimeSerial(File.hour, File.minute, File.second)
  919.  
  920.   File.FileName = Left$(DTA.FileName, InStr(DTA.FileName, Chr$(0)) - 1)
  921.   dot = InStr(File.FileName, ".")
  922.   If dot Then
  923.     File.name83 = Left$(File.FileName, dot - 1)
  924.     Mid$(File.name83, 9) = Mid$(File.FileName, dot + 1)
  925.   Else
  926.     File.name83 = File.FileName
  927.   End If
  928.   File.name38 = Right$(File.name83, 3) + Left$(File.name83, 8)
  929.  
  930. End Sub
  931.  
  932. Function FileGetDateTime (FileSpec$, DateTime#)
  933.  
  934. 'Initialization
  935.   Dim Regs As VBRegs, Rtn%, hFile%
  936.   Dim DtaSeg%, DtaOff%, Spec$
  937.   Dim Tim&, Dat&, File As FileDataType
  938.  
  939. 'Insure valid file
  940.   If Not FileExists(FileSpec$) Then
  941.     FileGetDateTime = False
  942.     Exit Function
  943.   End If
  944.  
  945. 'Open file
  946.   Spec$ = FileSpec$ + Chr$(0)
  947.   Regs.AX = &H3D00
  948.   Regs.DS = GetSegment(Spec$)
  949.   Regs.DX = GetOffset(Spec$)
  950.   Rtn = VBInt(&H21, Regs, Regs)
  951.   If Regs.cFlag Then
  952.     FileGetDateTime = False
  953.     Exit Function
  954.   Else
  955.     hFile = Regs.AX
  956.   End If
  957.  
  958. 'Get date and time
  959.   Regs.AX = &H5700
  960.   Regs.BX = hFile
  961.   Rtn = VBInt(&H21, Regs, Regs)
  962.   If Regs.cFlag Then
  963.     FileGetDateTime = False
  964.     Exit Function
  965.   End If
  966.  
  967. 'Interpret data
  968.   Tim& = Regs.CX
  969.   If Tim& < 0 Then Tim& = Tim& + 65536
  970.   File.second = (Tim& And &H1F) * 2
  971.   File.minute = (Tim& \ &H20) And &H3F
  972.   File.hour = (Tim& \ &H800) And &H1F
  973.   Dat& = Regs.DX
  974.   File.day = Dat& And &H1F
  975.   File.month = (Dat& \ &H20) And &HF
  976.   File.year = ((Dat& \ &H200) And &H1F) + 1980
  977.   DateTime = DateSerial(File.year, File.month, File.day) + TimeSerial(File.hour, File.minute, File.second)
  978.   
  979. 'Close file
  980.   Regs.AX = &H3E00
  981.   Regs.BX = hFile
  982.   Rtn = VBInt(&H21, Regs, Regs)
  983.   If Not Regs.cFlag Then
  984.     FileGetDateTime = True
  985.   End If
  986.  
  987. End Function
  988.  
  989. Function FileRename% (OldName$, NewName$)
  990.   
  991. 'Known Problem: Access Denied on WfW 3.11 hard disks!
  992. 'Initialization
  993.   Dim Regs As VBRegs, Rtn%
  994.   Dim nOldName$, nNewName$
  995.  
  996. 'null terminate
  997.   nOldName$ = OldName$ + Chr$(0)
  998.   nNewName$ = NewName$ + Chr$(0)
  999.  
  1000. 'setup registers
  1001.   Regs.AX = &H5600
  1002.   Regs.DS = GetSegment(nOldName$)
  1003.   Regs.DX = GetOffset(nOldName$)
  1004.   Regs.ES = GetSegment(nNewName$)
  1005.   Regs.DI = GetOffset(nNewName$)
  1006.   Rtn = VBInt(&H21, Regs, Regs)
  1007.  
  1008. 'test success
  1009.   If Regs.cFlag Then
  1010.     NewName$ = DosErrorMsg$(Regs.AX)
  1011.     FileRename = False
  1012.   Else
  1013.     FileRename = True
  1014.   End If
  1015.  
  1016. End Function
  1017.  
  1018. Function FileSetDateTime (FileSpec$, DateTime#)
  1019.  
  1020. 'Initialization
  1021.   Dim Regs As VBRegs, Rtn%, hFile%
  1022.   Dim DtaSeg%, DtaOff%, Spec$
  1023.   Dim Tim&, Dat&
  1024.  
  1025. 'Insure valid file
  1026.   If Not FileExists(FileSpec$) Then
  1027.     FileSetDateTime = False
  1028.     Exit Function
  1029.   End If
  1030.  
  1031. 'Open file
  1032.   Spec$ = FileSpec$ + Chr$(0)
  1033.   Regs.AX = &H3D00
  1034.   Regs.DS = GetSegment(Spec$)
  1035.   Regs.DX = GetOffset(Spec$)
  1036.   Rtn = VBInt(&H21, Regs, Regs)
  1037.   If Regs.cFlag Then
  1038.     FileSetDateTime = False
  1039.     Exit Function
  1040.   Else
  1041.     hFile = Regs.AX
  1042.   End If
  1043.  
  1044. 'Breakout data
  1045.   Tim& = Hour(DateTime) * &H800 + Minute(DateTime) * &H20 + Second(DateTime) \ 2
  1046.   If Tim& > &H7FFF Then
  1047.     Regs.CX = Tim& - 65536
  1048.   Else
  1049.     Regs.CX = Tim&
  1050.   End If
  1051.   Dat& = (Year(DateTime) - 1980) * &H200 + Month(DateTime) * &H20 + Day(DateTime)
  1052.   Regs.DX = Dat&
  1053.  
  1054. 'Set date and time
  1055.   Regs.AX = &H5701
  1056.   Regs.BX = hFile
  1057.   Rtn = VBInt(&H21, Regs, Regs)
  1058.   If Regs.cFlag Then
  1059.     FileSetDateTime = False
  1060.     Exit Function
  1061.   End If
  1062.  
  1063. 'Close file
  1064.   Regs.AX = &H3E00
  1065.   Regs.BX = hFile
  1066.   Rtn = VBInt(&H21, Regs, Regs)
  1067.   If Not Regs.cFlag Then
  1068.     FileSetDateTime = True
  1069.   End If
  1070.  
  1071. End Function
  1072.  
  1073. Function FillDirArray (ByVal ThePath$, File() As FileDataType, Attribute%, IncludeCurrent%, IncludeParent%)
  1074.  
  1075. 'Initialization
  1076.   Dim Regs As VBRegs
  1077.   Dim Rtn%, Num%
  1078.   Dim DtaSeg%, DtaOff%
  1079.   Dim DTA As DTAType
  1080.  
  1081. 'The path must be a null terminated string
  1082.   ThePath$ = Trim$(ThePath$) + Chr$(0)
  1083.  
  1084. 'Get current DTA address
  1085.   Regs.AX = &H2F00
  1086.   Rtn% = VBInt(&H21, Regs, Regs)
  1087.   DtaSeg = Regs.ES
  1088.   DtaOff = Regs.BX
  1089.  
  1090. 'Set dta address
  1091.   Regs.AX = &H1A00
  1092.   Regs.DS = UDTSegment(DTA)
  1093.   Regs.DX = UDTOffset(DTA)
  1094.   Rtn% = VBInt(&H21, Regs, Regs)
  1095.  
  1096. 'Find first file match
  1097.   Regs.AX = &H4E00
  1098.   Regs.CX = Attribute
  1099.   Regs.DS = GetSegment(ThePath$)
  1100.   Regs.DX = GetOffset(ThePath$)
  1101.   Rtn% = VBInt(&H21, Regs, Regs)
  1102.  
  1103. 'The carry flag tells if a file was found or not
  1104.   If Regs.cFlag And 1 Then 'Carry Flag Set
  1105.     FillDirArray = Regs.AX
  1106.     ReDim File(0) As FileDataType
  1107.   Else  'Carry Flag Clear
  1108.     'Proceed filling the array if FileFindFirst is successful
  1109.     'Enter loop of FindFileNext calls
  1110.       Do
  1111.     If InStr(DTA.FileName, ".") = 1 Then
  1112.       If InStr(2, DTA.FileName, ".") = 2 Then
  1113.         If IncludeParent Then
  1114.           ReDim Preserve File(0 To Num)
  1115.           FileGetData DTA, File(Num)
  1116.           Num = Num + 1
  1117.         End If
  1118.       ElseIf IncludeCurrent Then
  1119.         ReDim Preserve File(0 To Num)
  1120.         FileGetData DTA, File(Num)
  1121.         Num = Num + 1
  1122.       End If
  1123.     Else
  1124.       ReDim Preserve File(0 To Num)
  1125.       FileGetData DTA, File(Num)
  1126.       Num = Num + 1
  1127.     End If
  1128.   
  1129.     Regs.AX = &H4F00
  1130.     Rtn% = VBInt(&H21, Regs, Regs)
  1131.       Loop Until (Regs.cFlag And 1)
  1132.       Num = Num - 1
  1133.     'Return Success
  1134.       FillDirArray = 0
  1135.   End If
  1136.  
  1137. 'Reset the original DTA
  1138.   Regs.AX = &H1A00
  1139.   Regs.DS = DtaSeg
  1140.   Regs.DX = DtaOff
  1141.   Rtn% = VBInt(&H21, Regs, Regs)
  1142.  
  1143. End Function
  1144.  
  1145. Sub FillDirTreeArray (DirArray$(), ByVal StartDir$, CurrentLevel%)
  1146.  
  1147.   Static FileSpec$, Ndx%
  1148.   If CurrentLevel = 0 Then
  1149.     If InStr(LTrim$(StartDir$), " ") Then
  1150.       StartDir$ = LTrim$(Left$(StartDir$, InStr(StartDir$, " ") - 1))
  1151.     End If
  1152.     If Right$(StartDir$, 1) <> "\" Then
  1153.       StartDir$ = StartDir$ + "\"
  1154.     End If
  1155.     FileSpec$ = "*.*" + Chr$(0)
  1156.     Ndx = 0
  1157.     CurrentLevel = 1
  1158.     ReDim DirArray(0 To 0)
  1159.   End If
  1160.   
  1161.   Dim ThePath$, ThisDir$
  1162.   Dim Regs As VBRegs, Rtn%
  1163.   Dim DtaSeg%, DtaOff%
  1164.   Dim DTA As DTAType
  1165.   ThePath$ = StartDir$ + FileSpec$
  1166.   
  1167.   'Find the first match
  1168.     'Get current DTA address
  1169.       Regs.AX = &H2F00
  1170.       Rtn% = VBInt(&H21, Regs, Regs)
  1171.       DtaSeg = Regs.ES
  1172.       DtaOff = Regs.BX
  1173.     'Set dta address
  1174.       Regs.AX = &H1A00
  1175.       Regs.DS = UDTSegment(DTA)
  1176.       Regs.DX = UDTOffset(DTA)
  1177.       Rtn% = VBInt(&H21, Regs, Regs)
  1178.     'Find first file match
  1179.       Regs.AX = &H4E00
  1180.       Regs.CX = attrAllDir
  1181.       Regs.DS = GetSegment(ThePath$)
  1182.       Regs.DX = GetOffset(ThePath$)
  1183.       Rtn% = VBInt(&H21, Regs, Regs)
  1184.     'Check if done with this branch
  1185.       If Regs.cFlag And 1 Then 'No subdirectories
  1186.     Exit Sub
  1187.       End If
  1188.  
  1189.   'Begin recursion *********************
  1190.     Do
  1191.       If Asc(DTA.Attribute) And attrDirectory Then
  1192.     If Not InStr(DTA.FileName, ".") = 1 Then 'not Parent or Current dir
  1193.       ThisDir$ = Left$(DTA.FileName, InStr(DTA.FileName, Chr$(0)) - 1)
  1194.       DirArray(Ndx) = StartDir$ + ThisDir$
  1195.       Ndx = Ndx + 1
  1196.       ReDim Preserve DirArray(0 To Ndx)
  1197.       'Look down further
  1198.         FillDirTreeArray DirArray(), StartDir$ + ThisDir$ + "\", CurrentLevel + 1
  1199.       'Setup for FileFindNext
  1200.         Regs.CX = attrAllDir
  1201.         Regs.DS = GetSegment(ThePath$)
  1202.         Regs.DX = GetOffset(ThePath$)
  1203.     End If
  1204.       End If
  1205.  
  1206.       'Search for next match
  1207.     Regs.AX = &H4F00
  1208.     Rtn% = VBInt(&H21, Regs, Regs)
  1209.     If Regs.cFlag And 1 Then 'no more dirs
  1210.       Exit Do
  1211.     End If
  1212.     Loop
  1213.  
  1214.   'Reset the original DTA
  1215.     Regs.AX = &H1A00
  1216.     Regs.DS = DtaSeg
  1217.     Regs.DX = DtaOff
  1218.     Rtn% = VBInt(&H21, Regs, Regs)
  1219.  
  1220. End Sub
  1221.  
  1222.